home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
DELPHI32
/
GRIDS
/
IMPGRID
/
IMPGRID.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-10-29
|
10KB
|
319 lines
{$A+,B-,C-,D+,E-,F-,G+,H+,I+,J+,K-,L+,M-,N+,O+,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y-,Z1}
{$MINSTACKSIZE $00004000}
{$MAXSTACKSIZE $00100000}
{$IMAGEBASE $00400000}
{$APPTYPE GUI}
unit impgrid;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Grids;
type
Timpgrid = class(TStringGrid)
private
FlightColor: tcolor;
FDarkColor: tcolor;
FGridLineColor: tcolor;
FFixedJustify: integer;
FJustify: integer;
Foffset: integer;
FColFontColor: string;
FFixedFont: tfont;
FVertLab: boolean;
procedure setLightColor(value: tcolor);
procedure setDarkColor(value: tcolor);
procedure setGridLineColor(value: tcolor);
procedure setFixedJustify(value: integer);
procedure setJustify(value: integer);
procedure setoffset(value: integer);
procedure setColFontColor(value: string);
procedure setFixedFont(value: tfont);
procedure setvertLab(value: boolean);
{ Private declarations }
protected
procedure DrawCell(ACol, ARow: longint; ARect: TRect;
AState: TGridDrawState); override;
{ Protected declarations }
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Align;
property ColCount;
property DefaultColWidth;
property DefaultRowHeight;
property EditorMode;
property Gridlinewidth;
property Options;
property RowCount;
property ScrollBars;
property LightColor: tcolor read FLightColor write setLightColor; {default $02ffffff; }
property DarkColor: tcolor read FDarkColor write setDarkColor; {default $0280ff80; }
property GridLineColor: tcolor read FGridLineColor write setGridLineColor; {default $0220ff20; }
property FixedJustify: integer read FFixedJustify write setFixedJustify; {default 0; }
property Justify: integer read FJustify write setJustify; {default 1; }
property ColFontColor:string read FColFontColor write setColFontColor; {default 'clblack'; }
property offset: integer read FOffset write setOffset; {default 0; }
property FixedFont: tfont read FFixedFont write setFixedFont; {default parentfont;}
property VertLab: boolean read FVertLab write setVertLab;
property OnClick;
property OnColumnMoved;
property OnDblClick;
property OnDragDrop;
property OnDrawCell;
property OnEnter;
property OnExit;
property OnRowMoved;
property OnTopLeftChanged;
property OnMouseDown;
procedure SaveToFile(filename: string);
procedure LoadFromFile(filename: string);
procedure SetColColor(col: longint; color: string);
procedure AddCol;
procedure FixedFontChanged(Sender: Tobject);
end;
procedure Register;
implementation
constructor timpgrid.Create(AOwner: TComponent);
var i: longint;
begin
inherited Create(AOwner); { call inherited Constructor... }
FFixedFont := tFont.create;
FFixedFont.onchange := FixedFontChanged;
{temporary} colfontcolor := 'clblue';
for i := 0 to Colcount do cells[i,fixedrows] := ColFontColor;
end;
destructor timpgrid.Destroy;
begin
{FFixedFont.free;}
inherited Destroy;
end;
procedure Register;
begin
RegisterComponents('Additional', [timpgrid]);
end;
procedure timpgrid.DrawCell(ACol, ARow: longint; ARect: TRect;
AState: TGridDrawState);
var
lfont: TLOGFONT;
thefont: hfont;
oldfont: hfont;
s:pchar;
clr: tcolor;
str: string[10];
begin
canvas.font.assign(font);
with canvas do
if (ACol < fixedcols) or (ARow < FixedRows) then { fixed box... }
begin
if vertlab and (ARow = 0) then { vertical labels }
begin
begin
{s := stralloc(12);}
with lfont do
begin
lfHeight:= defaultcolwidth - 8;
lfWidth:=5;
lfEscapement:= 900; {this is angle}
{lfOrientation: Integer; }
lfWeight:= {4}500;
lfItalic:= 0;
lfUnderline:= 0;
lfStrikeOut:= 0;
{lfCharSet: Byte;}
lfOutPrecision:= 255;
{lfClipPrecision: Byte;}
lfQuality:= 255;
{lfPitchAndFamily: Byte;
lfFaceName: array[0..lf_FaceSize - 1] of Char;}
strpcopy(lffacename,'Times New Roman');
end;
canvas.brush.color := Fixedcolor;
thefont := createfontindirect(lfont);
oldfont := selectobject(canvas.handle, thefont);
{str := cells[acol,arow];
strpcopy(s,str); }
SetTextColor(canvas.handle,fixedfont.color); {this needs to be the same color as the rest of the column}
canvas.textout(arect.left+4,arect.bottom-5,cells[acol,arow]);
{strdispose(s);}
thefont := selectobject(canvas.handle, oldfont);
deleteobject(thefont);
end;
end
else
begin
font := FFixedFont;
brush.color := FixedColor;
if fixedjustify = 0 then textrect(arect, arect.left+2
,arect.top+2,cells[acol,arow]) { left justify... }
else textrect(arect, arect.right-textwidth(cells[acol,arow])-3
,arect.top+2,cells[acol,arow]);{ right justify... }
end;
end
else { not fixed... }
begin
{ determine brush color... }
if (trunc((trunc((arow+offset)/4+0.0001))*4) = arow+offset)
or
(trunc((trunc((arow-1+offset)/4+0.0001))*4) = arow-1+offset) then
brush.color := lightcolor
else brush.color := darkcolor;
try
font.color := stringtocolor(colfontcolor){stringtocolor(cells[acol,fixedrows])}; { set font color }
except
on EConvertError do font.color := clblack;
end;
if justify = 0 then textrect(arect, arect.left+2
,arect.top+2,cells[acol,arow]) { left justify... }
else textrect(arect, arect.right-textwidth(cells[acol,arow])-3
,arect.top+2,cells[acol,arow]);{ right justify... }
end;
end;
procedure timpgrid.SetColColor(col: longint; color: string);
begin
{cells[col,fixedrows] := color; }
end;
procedure timpgrid.SaveToFile(filename: string);
var i,j: integer;
f: textfile;
begin
{open file for output...}
assignfile(f,filename);
rewrite(f); {reset for output...}
{add header}
writeln(f,'Don Morris Improved Grid File');
writeln(f,'Do < NOT > mess with this!!!');
writeln(f,colcount);
writeln(f,rowcount);
for i := 0 to colcount do
for j := 0 to rowcount do
writeln(f,cells[i,j]); {write in all the grades...}
writeln(f,'yes it is a long file in text format.');
writeln(f, 'Tamper with it and lose it!!!');
closefile(f);
end;
procedure timpgrid.LoadFromFile(filename: string);
var i,j,cols,rows: integer;
f: textfile;
cell: string;
begin
{open file for input...}
assignfile(f,filename);
reset(f); {reset for input...}
{add header}
readln(f{,'Don Morris Improved Grid File'});
readln(f{,'Do < NOT > mess with this!!!'});
readln(f,cols);
colcount := cols;
readln(f,rows);
rowcount := rows;
for i := 0 to colcount do
for j := 0 to rowcount do
begin
readln(f,cell); {write in all the grades...}
cells[i,j] := cell;
end;
{last two lines ignored}
closefile(f);
end;
procedure timpgrid.AddCol;
begin
colcount := colcount +1;
cells[colcount,fixedrows] := colfontcolor; { new font color default is black... }
end;
{set new properties...}
procedure timpgrid.setvertlab(value: boolean);
begin
if Fvertlab <> value then
begin
Fvertlab := value;
Invalidate;
end;
end;
procedure timpgrid.setLightColor(value: tcolor);
begin
if FLightColor <> value then
begin
FLightColor := value;
Invalidate;
end;
end;
procedure timpgrid.setDarkColor(value: tcolor);
begin
if FDarkColor <> value then
begin
FDarkColor := value;
Invalidate;
end;
end;
procedure timpgrid.setGridLineColor(value: tcolor);
begin
if FGridLineColor <> value then
begin
FGridLineColor := value;
Invalidate;
end;
end;
procedure timpgrid.setFixedJustify(value: integer);
begin
if FFixedJustify <> value then
begin
FFixedJustify := value;
Invalidate;
end;
end;
procedure timpgrid.setJustify(value: integer);
begin
if FJustify <> value then
begin
FJustify := value;
Invalidate;
end;
end;
procedure timpgrid.setoffset(value: integer);
begin
if Foffset <> value then
begin
Foffset := value;
Invalidate;
end;
end;
procedure timpgrid.setColFontColor(value: string);
begin
if FColFontColor <> value then
begin
FColFontColor := value;
Invalidate;
end;
end;
procedure timpgrid.setFixedFont(value: tfont);
begin
FFixedFont.assign(value);
end;
procedure timpgrid.FixedFontchanged(Sender: Tobject);
begin
Invalidate;
end;
end.